POINT Software Programming/PPROG1.ISO/pascal/swag/graphics.swg/0062_Writing PCX files.pas

Pascal/Delphi Source File | 1993-11-21 | 11.9 KB | 405 lines

{
From: WILLIAM PLANKE
Subj: Write PCX example 1/4

As I follow this forum, many requests are made for PCX graphics
file routines. Those that are looking for Read_PCX info can
find it on the ZSoft BBS in a wonderful Pascal example: ShowPCX.

On the other hand, there is next to zilch out there on how to
Write_PCX files. I know.... I searched and searched and couldn't
find a thing! So with a little brute force  and a few ZSoft
C language snippets <groan>, I got this together:
}


{ =================== TPv6.0  P C X _ W ======================== }

{$R-}    {Range checking, turn off when debugged}

unit PCX_W;

{ --------------------- Interface ----------------- }

interface

type
    Str80 = string [80];

procedure Write_PCX  (Name:Str80);


{ ===================== Implementation ============ }

implementation

uses
    Graph;


{-------------- Write_PCX --------------}

procedure Write_PCX (Name:Str80);

const
     RED1   = 0;
     GREEN1 = 1;
     BLUE1  = 2;

type
    ArrayPal   = array [0..15, RED1..BLUE1] of byte;

const
     MAX_WIDTH  = 4000;    { arbitrary - maximum width (in bytes) of
                             a PCX image }
     INTENSTART =   $5;
     BLUESTART  =  $55;
     GREENSTART =  $A5;
     REDSTART   =  $F5;

type
    Pcx_Header = record
    {comments from ZSoft ShowPCX pascal example}

        Manufacturer: byte;     { Always 10 for PCX file }

        Version: byte;          { 2 - old PCX - no palette (not used
                                      anymore),
                                  3 - no palette,
                                  4 - Microsoft Windows - no palette
                                      (only in old files, new Windows
                                      version uses 3),
                                  5 - with palette }

        Encoding: byte;         { 1 is PCX, it is possible that we may
                                  add additional encoding methods in the
                                  future }

        Bits_per_pixel: byte;   { Number of bits to represent a pixel
                                  (per plane) - 1, 2, 4, or 8 }

        Xmin: integer;          { Image window dimensions (inclusive) }
        Ymin: integer;          { Xmin, Ymin are usually zero (not always)}
        Xmax: integer;
        Ymax: integer;

        Hdpi: integer;          { Resolution of image (dots per inch) }
        Vdpi: integer;          { Set to scanner resolution - 300 is
                                  default }

        ColorMap: ArrayPal;
                                { RGB palette data (16 colors or less)
                                  256 color palette is appended to end
                                  of file }

        Reserved: byte;         { (used to contain video mode)
                                  now it is ignored - just set to zero }

        Nplanes: byte;          { Number of planes }

        Bytes_per_line_per_plane: integer;   { Number of bytes to
                                               allocate for a scanline
                                               plane. MUST be an an EVEN
                                               number! Do NOT calculate
                                               from Xmax-Xmin! }

        PaletteInfo: integer;   { 1 = black & white or color image,
                                  2 = grayscale image - ignored in PB4,
                                      PB4+ palette must also be set to
                                      shades of gray! }

        HscreenSize: integer;   { added for PC Paintbrush IV Plus
                                  ver 1.0,  }
        VscreenSize: integer;   { PC Paintbrush IV ver 1.02 (and later)}
                                { I know it is tempting to use these
                                  fields to determine what video mode
                                  should be used to display the image
                                  - but it is NOT recommended since the
                                  fields will probably just contain
                                  garbage. It is better to have the
                                  user install for the graphics mode he
                                  wants to use... }

        Filler: array [74..127] of byte;     { Just set to zeros }
    end;

    Array80    = array [1..80]        of byte;
    ArrayLnImg = array [1..326]       of byte; { 6 extra bytes at
     beginng of line that BGI uses for size info}
    Line_Array = array [0..MAX_WIDTH] of byte;
    ArrayLnPCX = array [1..4]         of Array80;

var
   PCXName   : File;
   Header    : Pcx_Header;                 { PCX file header }
   ImgLn     : ArrayLnImg;
   PCXLn     : ArrayLnPCX;
   RedLn,
   BlueLn,
   GreenLn,
   IntenLn   : Array80;
   Img       : pointer;


{-------------- BuildHeader- -----------}

procedure BuildHeader;

const
     PALETTEMAP: ArrayPal=
                 {  R    G    B                    }
                (($00, $00, $00),  {  black        }
                 ($00, $00, $AA),  {  blue         }
                 ($00, $AA, $00),  {  green        }
                 ($00, $AA, $AA),  {  cyan         }
                 ($AA, $00, $00),  {  red          }
                 ($AA, $00, $AA),  {  magenta      }
                 ($AA, $55, $00),  {  brown        }
                 ($AA, $AA, $AA),  {  lightgray    }
                 ($55, $55, $55),  {  darkgray     }
                 ($55, $55, $FF),  {  lightblue    }
                 ($55, $FF, $55),  {  lightgreen   }
                 ($55, $FF, $FF),  {  lightcyan    }
                 ($FF, $55, $55),  {  lightred     }
                 ($FF, $55, $FF),  {  lightmagenta }
                 ($FF, $FF, $55),  {  yellow       }
                 ($FF, $FF, $FF) );{  white        }

var
   i : word;

begin
     with Header do
          begin
               Manufacturer  := 10;
               Version  := 5;
               Encoding := 1;
               Bits_per_pixel := 1;
               Xmin := 0;
               Ymin := 0;
               Xmax := 639;
               Ymax := 479;
               Hdpi := 640;
               Vdpi := 480;
               ColorMap := PALETTEMAP;
               Reserved := 0;
               Nplanes  := 4; { Red, Green, Blue, Intensity }
               Bytes_per_line_per_plane := 80;
               PaletteInfo := 1;
               HscreenSize := 0;
               VscreenSize := 0;
               for i := 74 to 127 do
                   Filler [i] := 0;
          end;
end;


{-------------- GetBGIPlane ------------}

procedure GetBGIPlane (Start:word; var Plane:Array80);

var
   i : word;

begin
     for i:= 1 to Header.Bytes_per_line_per_plane do
         Plane [i] := ImgLn [Start +i -1]
end;

{-------------- BuildPCXPlane ----------}

procedure BuildPCXPlane (Start:word; Plane:Array80);

var
   i : word;

begin
     for i := 1 to Header.Bytes_per_line_per_plane do
         PCXLn [Start] [i] := Plane [i];
end;


{-------------- EncPCXLine -------------}

procedure EncPCXLine (PlaneLine : word); { Encode a PCX line }

var
   This,
   Last,
   RunCount : byte;
   i,
   j        : word;


  {-------------- EncPut -----------------}

  procedure EncPut (Byt, Cnt :byte);

  const
       COMPRESS_NUM = $C0;  { this is the upper two bits that
                              indicate a count }

  var
     Holder : byte;

  begin
  {$I-}
       if (Cnt = 1) and (COMPRESS_NUM <> (COMPRESS_NUM and Byt)) then
          blockwrite (PCXName, Byt,1)          { single occurance }
          {good place for file error handler!}
       else
           begin
                Holder := (COMPRESS_NUM or Cnt);
                blockwrite (PCXName, Holder, 1); { number of times the
                                                   following color
                                                   occurs }
                blockwrite (PCXName, Byt, 1);
           end;
  {$I+}
  end;


begin
     i := 1;         { used in PCXLn }
     RunCount := 1;
     Last := PCXLn [PlaneLine][i];
     for j := 1 to Header.Bytes_per_line_per_plane -1 do
         begin
              inc (i);
              This := PCXLn [PlaneLine][i];
              if This = Last then
                 begin
                      inc (RunCount);
                      if RunCount = 63 then   { reached PCX run length
                                                limited max yet? }
                         begin
                              EncPut (Last, RunCount);
                              RunCount := 0;
                         end;
                 end
              else
                  begin
                       if RunCount >= 1 then
                          Encput (Last, RunCount);
                       Last := This;
                       RunCount := 1;
                  end;
         end;
     if RunCount >= 1 then  { any left over ? }
        Encput (Last, RunCount);
end;

            { - - -W-R-I-T-E-_-P-C-X- - - - - - - - }

const
     XMAX = 639;
     YMAX = 479;

var
   i, j, Size : word;

begin
     BuildHeader;
     assign     (PCXName,Name);
{$I-}
     rewrite    (PCXName,1);
     blockwrite (PCXName,Header,sizeof (Header));
     {good place for file error handler!}
{$I+}
     setviewport (0,0,XMAX,YMAX, ClipOn);
     Size := imagesize (0,0,XMAX,0); { size of a single row }
     getmem (Img,Size);

     for i := 0 to YMAX do
         begin
              getimage (0,i,XMAX,i,Img^);  { Grab 1 line from the
                                             screen store in Img
                                             buffer  }
              move (Img^,ImgLn,Size {326});


              GetBGIPlane (INTENSTART, IntenLn);
              GetBGIPlane (BLUESTART,  BlueLn );
              GetBGIPlane (GREENSTART, GreenLn);
              GetBGIPlane (REDSTART,   RedLn  );
              BuildPCXPlane (1, RedLn  );
              BuildPCXPlane (2, GreenLn);
              BuildPCXPlane (3, BlueLn );
              BuildPCXPlane (4, IntenLn); { 320 bytes/line
                                            uncompressed }
              for j := 1 to Header.NPlanes do

                  EncPCXLine (j);
         end;
     freemem (Img,Size);           (* Release the memory        *)
{$I-}
     close (PCXName);              (* Save the Image            *)
{$I+}
end;

end {PCX.TPU} .


{ -----------------------Test Program -------------------------- }

program WritePCX;

uses
    Graph, PCX_W;

{-------------- DrawHorizBars ----------}

procedure DrawHorizBars;

var
   i, Color : word;

begin
     cleardevice;
     Color := 15;
     for i := 0 to 15 do
         begin
              setfillstyle (solidfill,Color);
              bar (0,i*30,639,i*30+30);       { 16*30 = 480 }
              dec (Color);
         end;
end;

{-------------- Main -------------------}

var
   NameW : Str80;
   Gd,
   Gm    : integer;

begin
     writeln;
     if (ParamCount = 0) then           { no DOS command line
                                          parameters }
        begin
             write ('Enter name of PCX picture file to write: ');
             readln (NameW);
             writeln;
        end
     else
         begin
              NameW := paramstr (1);  { get filename from DOS
                                        command line }
         end;

     if (Pos ('.', NameW) = 0) then   { make sure the filename
                                        has PCX extension }
        NameW := Concat (NameW, '.pcx');

     Gd:=VGA;
     Gm:=VGAhi; {640x480, 16 colors}
     initgraph (Gd,Gm,'..\bgi');  { path to your EGAVGA.BGI }

     DrawHorizBars;

     readln;
     Write_PCX (NameW); { PCX_W.TPU }
     closegraph;                    { Close graphics    }
     textmode (co80);               { back to text mode }
end.  { Write_PCX }